home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / numerical / slatec / xersve.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  6.4 KB  |  136 lines
  1. ;;; Compiled by f2cl version 2.0 beta 2002-05-06
  2. ;;; 
  3. ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  4. ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  5. ;;;           (:array-slicing nil) (:declare-common nil)
  6. ;;;           (:float-format double-float))
  7.  
  8. (in-package "SLATEC")
  9.  
  10.  
  11. (let* ((lentab 10))
  12.   (declare (type f2cl-lib:integer4 lentab))
  13.   (let ((libtab (f2cl-lib:f2cl-init-string ((+ 1 (- lentab 1))) (8)))
  14.         (subtab (f2cl-lib:f2cl-init-string ((+ 1 (- lentab 1))) (8)))
  15.         (mestab (f2cl-lib:f2cl-init-string ((+ 1 (- lentab 1))) (20)))
  16.         (nertab (make-array lentab :element-type 'f2cl-lib:integer4))
  17.         (levtab (make-array lentab :element-type 'f2cl-lib:integer4))
  18.         (kount (make-array lentab :element-type 'f2cl-lib:integer4))
  19.         (kountx 0)
  20.         (nmsg 0))
  21.     (declare (type f2cl-lib:integer4 nmsg kountx)
  22.              (type (simple-array f2cl-lib:integer4 (*)) kount levtab nertab)
  23.              (type (simple-array (simple-array base-char (20)) (*)) mestab)
  24.              (type (simple-array (simple-array base-char (8)) (*)) subtab
  25.               libtab))
  26.     (setq kountx 0)
  27.     (setq nmsg 0)
  28.     (defun xersve (librar subrou messg kflag nerr level icount)
  29.       (declare (type f2cl-lib:integer4 icount level nerr kflag)
  30.                (type (simple-array base-char (*)) messg subrou librar))
  31.       (prog ((mes
  32.               (make-array '(20)
  33.                           :element-type
  34.                           'base-char
  35.                           :initial-element
  36.                           #\Space))
  37.              (lib
  38.               (make-array '(8)
  39.                           :element-type
  40.                           'base-char
  41.                           :initial-element
  42.                           #\Space))
  43.              (sub
  44.               (make-array '(8)
  45.                           :element-type
  46.                           'base-char
  47.                           :initial-element
  48.                           #\Space))
  49.              (lun (make-array 5 :element-type 'f2cl-lib:integer4)) (i 0)
  50.              (iunit 0) (kunit 0) (nunit 0))
  51.         (declare (type f2cl-lib:integer4 nunit kunit iunit i)
  52.                  (type (simple-array base-char (20)) mes)
  53.                  (type (simple-array base-char (8)) lib sub)
  54.                  (type (simple-array f2cl-lib:integer4 (5)) lun))
  55.         (cond
  56.          ((<= kflag 0) (if (= nmsg 0) (go end_label))
  57.           (multiple-value-bind
  58.               (var-0 var-1)
  59.               (xgetua lun nunit)
  60.             (declare (ignore var-0))
  61.             (setf nunit var-1))
  62.           (f2cl-lib:fdo (kunit 1 (f2cl-lib:int-add kunit 1))
  63.                         ((> kunit nunit) nil)
  64.             (tagbody
  65.               (setf iunit (f2cl-lib:fref lun (kunit) ((1 5))))
  66.               (if (= iunit 0) (setf iunit (f2cl-lib:i1mach 4)))
  67.               (f2cl-lib:fformat iunit
  68.                                 ("0          ERROR MESSAGE SUMMARY" "~%"
  69.                                  " LIBRARY    SUBROUTINE MESSAGE START             NERR"
  70.                                  "     LEVEL     COUNT" "~%")
  71.                                 nil)
  72.               (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  73.                             ((> i nmsg) nil)
  74.                 (tagbody
  75.                   (f2cl-lib:fformat iunit
  76.                                     ("~1@T" ("~A") "~3@T" ("~A") "~3@T" ("~A")
  77.                                      3 (("~10D")) "~%")
  78.                                     (f2cl-lib:fref libtab (i) ((1 lentab)))
  79.                                     (f2cl-lib:fref subtab (i) ((1 lentab)))
  80.                                     (f2cl-lib:fref mestab (i) ((1 lentab)))
  81.                                     (f2cl-lib:fref nertab (i) ((1 lentab)))
  82.                                     (f2cl-lib:fref levtab (i) ((1 lentab)))
  83.                                     (f2cl-lib:fref kount (i) ((1 lentab))))
  84.                  label10))
  85.               (if (/= kountx 0)
  86.                   (f2cl-lib:fformat iunit
  87.                                     ("0OTHER ERRORS NOT INDIVIDUALLY TABULATED = "
  88.                                      1 (("~10D")) "~%")
  89.                                     kountx))
  90.               (f2cl-lib:fformat iunit ("~1@T" "~%") nil)
  91.              label20))
  92.           (cond ((= kflag 0) (setf nmsg 0) (setf kountx 0))))
  93.          (t (f2cl-lib:f2cl-set-string lib librar (string 8))
  94.           (f2cl-lib:f2cl-set-string sub subrou (string 8))
  95.           (f2cl-lib:f2cl-set-string mes messg (string 20))
  96.           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  97.                         ((> i nmsg) nil)
  98.             (tagbody
  99.               (cond
  100.                ((and
  101.                  (f2cl-lib:fstring-= lib
  102.                                      (f2cl-lib:fref libtab (i) ((1 lentab))))
  103.                  (f2cl-lib:fstring-= sub
  104.                                      (f2cl-lib:fref subtab (i) ((1 lentab))))
  105.                  (f2cl-lib:fstring-= mes
  106.                                      (f2cl-lib:fref mestab (i) ((1 lentab))))
  107.                  (= nerr (f2cl-lib:fref nertab (i) ((1 lentab))))
  108.                  (= level (f2cl-lib:fref levtab (i) ((1 lentab)))))
  109.                 (f2cl-lib:fset (f2cl-lib:fref kount (i) ((1 lentab)))
  110.                                (f2cl-lib:int-add
  111.                                 (f2cl-lib:fref kount (i) ((1 lentab)))
  112.                                 1))
  113.                 (setf icount (f2cl-lib:fref kount (i) ((1 lentab))))
  114.                 (go end_label)))
  115.              label30))
  116.           (cond
  117.            ((< nmsg lentab) (setf nmsg (f2cl-lib:int-add nmsg 1))
  118.             (f2cl-lib:f2cl-set-string (f2cl-lib:fref libtab (i) ((1 lentab)))
  119.                                       lib
  120.                                       (string 8))
  121.             (f2cl-lib:f2cl-set-string (f2cl-lib:fref subtab (i) ((1 lentab)))
  122.                                       sub
  123.                                       (string 8))
  124.             (f2cl-lib:f2cl-set-string (f2cl-lib:fref mestab (i) ((1 lentab)))
  125.                                       mes
  126.                                       (string 20))
  127.             (f2cl-lib:fset (f2cl-lib:fref nertab (i) ((1 lentab))) nerr)
  128.             (f2cl-lib:fset (f2cl-lib:fref levtab (i) ((1 lentab))) level)
  129.             (f2cl-lib:fset (f2cl-lib:fref kount (i) ((1 lentab))) 1)
  130.             (setf icount 1))
  131.            (t (setf kountx (f2cl-lib:int-add kountx 1)) (setf icount 0)))))
  132.         (go end_label)
  133.        end_label
  134.         (return (values nil nil nil nil nil nil icount))))))
  135.  
  136.